Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/atileg1a/frmtilet.frm

Visual Basic Form | 1999-09-29 | 14.2 KB | 471 lines

VERSION 5.00
Begin VB.Form frmTileTest
   Caption         =   "Map Creation"
   ClientHeight    =   9420
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   10440
   LinkTopic       =   "Form1"
   ScaleHeight     =   628
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   696
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton vmdAbout
      Caption         =   "About"
      Height          =   375
      Left            =   150
      TabIndex        =   20
      Top             =   90
      Width           =   1155
   End
   Begin VB.PictureBox imgZoom
      Height          =   915
      Left            =   180
      ScaleHeight     =   855
      ScaleWidth      =   945
      TabIndex        =   19
      Top             =   540
      Width           =   1005
   End
   Begin VB.PictureBox Outer
      Height          =   6675
      Left            =   30
      ScaleHeight     =   441
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   345
      TabIndex        =   15
      Top             =   1500
      Width           =   5235
      Begin VB.HScrollBar HScroll1
         Height          =   255
         LargeChange     =   5
         Left            =   0
         Max             =   200
         TabIndex        =   18
         Top             =   7830
         Width           =   7905
      End
      Begin VB.VScrollBar VScroll1
         Height          =   8085
         LargeChange     =   5
         Left            =   7920
         Max             =   200
         TabIndex        =   17
         Top             =   0
         Width           =   285
      End
      Begin VB.PictureBox Inner
         BackColor       =   &H00FF0000&
         FillColor       =   &H00FF0000&
         Height          =   79650
         Left            =   0
         ScaleHeight     =   5306
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   4746
         TabIndex        =   16
         Top             =   0
         Width           =   71250
         Begin VB.Image imgSml
            Height          =   15
            Left            =   4200
            Top             =   5550
            Width           =   15
         End
         Begin VB.Image castle
            Height          =   720
            Index           =   0
            Left            =   690
            Picture         =   "frmTileTest.frx":0000
            Stretch         =   -1  'True
            Top             =   720
            Visible         =   0   'False
            Width           =   720
         End
         Begin VB.Image imgTile
            Appearance      =   0  'Flat
            BorderStyle     =   1  'Fixed Single
            Height          =   1440
            Index           =   0
            Left            =   0
            Picture         =   "frmTileTest.frx":3042
            Stretch         =   -1  'True
            Tag             =   "0"
            Top             =   0
            Width           =   1440
         End
      End
   End
   Begin VB.Frame Frame2
      Caption         =   "File"
      Height          =   1185
      Left            =   3510
      TabIndex        =   9
      Top             =   60
      Width           =   1995
      Begin VB.CommandButton Command1
         Caption         =   "Save"
         Height          =   255
         Left            =   390
         TabIndex        =   12
         Top             =   840
         Width           =   1125
      End
      Begin VB.CommandButton Command2
         Caption         =   "Load"
         Height          =   285
         Left            =   390
         TabIndex        =   11
         Top             =   540
         Width           =   1125
      End
      Begin VB.TextBox txtFile
         Height          =   285
         Left            =   930
         TabIndex        =   10
         Text            =   "out"
         Top             =   210
         Width           =   975
      End
      Begin VB.Label Label4
         AutoSize        =   -1  'True
         Caption         =   "Filename :"
         Height          =   195
         Left            =   180
         TabIndex        =   13
         Top             =   240
         Width           =   720
      End
   End
   Begin VB.Frame Frame1
      Caption         =   "Misc :"
      Height          =   975
      Left            =   5700
      TabIndex        =   5
      Top             =   180
      Width           =   1875
      Begin VB.TextBox Text1
         Height          =   285
         Left            =   1170
         TabIndex        =   7
         Text            =   "4"
         Top             =   240
         Width           =   555
      End
      Begin VB.CheckBox chkGrid
         Caption         =   "Grid On"
         Height          =   285
         Left            =   270
         TabIndex        =   6
         Top             =   600
         Value           =   1  'Checked
         Width           =   945
      End
      Begin VB.Label Label2
         AutoSize        =   -1  'True
         Caption         =   "Zoom Factor:"
         Height          =   195
         Left            =   180
         TabIndex        =   8
         Top             =   270
         Width           =   945
      End
   End
   Begin VB.Frame fmGridSize
      Caption         =   "Grid Size :"
      Height          =   1365
      Left            =   1380
      TabIndex        =   0
      Top             =   30
      Width           =   1965
      Begin VB.CommandButton cmdClear
         Caption         =   "Clear"
         Height          =   315
         Left            =   300
         TabIndex        =   14
         Top             =   960
         Width           =   1485
      End
      Begin VB.CommandButton cmdResize
         Caption         =   "Change Size"
         Height          =   285
         Left            =   300
         TabIndex        =   4
         Top             =   630
         Width           =   1455
      End
      Begin VB.TextBox txtCol
         Height          =   375
         Left            =   1200
         TabIndex        =   2
         Text            =   "20"
         Top             =   240
         Width           =   555
      End
      Begin VB.TextBox txtRow
         Height          =   375
         Left            =   240
         TabIndex        =   1
         Text            =   "20"
         Top             =   240
         Width           =   555
      End
      Begin VB.Label Label3
         AutoSize        =   -1  'True
         Caption         =   "by"
         Height          =   195
         Left            =   900
         TabIndex        =   3
         Top             =   330
         Width           =   165
      End
   End
   Begin VB.Image imgArrow
      Height          =   480
      Left            =   8700
      Picture         =   "frmTileTest.frx":3884
      Top             =   240
      Visible         =   0   'False
      Width           =   480
   End
Attribute VB_Name = "frmTileTest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' The main form,
' Click on a texture in the texture's form and then on a cell in this form to
' place it.
Option Explicit
Private CONSTPath As String
Const SEAPic = 53
Private ActiveTile As Integer
Private ZoomLevel As Double
Private Map As Map
'Private Tile(400) As Tile
Private ImageLoaded As Boolean
Private Sub castle_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, y As Single)
  castle(Index).Drag vbBeginDrag
End Sub
Private Sub chkGrid_Click()
Dim i As Integer
  If chkGrid.Value = vbChecked Then
    For i = 0 To Map.Rows * Map.Cols - 1
      imgTile(i).BorderStyle = 1
    Next
  Else
    For i = 0 To Map.Rows * Map.Cols - 1
      imgTile(i).BorderStyle = 0
    Next
  End If
End Sub
Private Sub cmdClear_Click()
Dim i As Integer
  For i = 0 To Map.Rows * Map.Cols - 1
    imgTile(i).Picture = frmTextures.picTile(SEAPic).Picture
    Map(i).Image = SEAPic
  Next
End Sub
Private Sub cmdResize_Click()
Dim i As Integer
  'Set Map = New Map
  Call Map.CreateArray(CInt(txtRow), CInt(txtCol))
  Call Map.ClearArray
  For i = 0 To imgTile.UBound - 1
    imgTile(i).Visible = False
  Next
  Call CreateImageArray
End Sub
Private Sub Command1_Click()
  Call WriteToFile
End Sub
Private Sub Command2_Click()
Dim i As Integer
  Call LoadDataFile(txtFile.Text)
  For i = 0 To imgTile.UBound - 1
    imgTile(i).Visible = False
  Next
  Call CreateImageArray
  Draw
End Sub
Private Sub Form_Load()
Dim i As Integer
  ZoomLevel = 2
  CONSTPath = App.Path & "\data\"
  Set Map = New Map
  Call Map.CreateArray(20, 20)
  Call Map.ClearArray
  Call CreateImageArray
  imgZoom.Picture = frmTextures.picTile(SEAPic).Picture
  imgZoom.Tag = SEAPic
  frmTextures.Show
  ImageLoaded = False
  frmTileTest.Show
  DoEvents
  ImageLoaded = True
End Sub
Private Sub CreateImageArray()
Dim i As Integer
  imgTile(0).Width = (16 * ZoomLevel)
  imgTile(0).Height = (16 * ZoomLevel)
  imgTile(0).Stretch = True
  imgTile(0).Visible = True
  For i = 1 To Map.Cols * Map.Rows - 1
On Error Resume Next
    Load imgTile(i)
On Error GoTo 0
   ' Set Map.Item(i) = New Tile
    imgTile(i).Visible = False
    imgTile(i).Left = imgTile(i - 1).Left + (16 * ZoomLevel)
    imgTile(i).Top = imgTile(i - 1).Top
    imgTile(i).ToolTipText = i
    If CDbl((i / Map.Cols) - CInt(i / Map.Cols)) = 0 Then
      imgTile(i).Top = imgTile(i - 1).Top + (16 * ZoomLevel)
      imgTile(i).Left = imgTile(0).Left
    End If
    imgTile(i).Width = (16 * ZoomLevel)
    imgTile(i).Height = (16 * ZoomLevel)
    imgTile(i).Stretch = True
    imgTile(i).Visible = True
  Next
End Sub
Private Sub LoadDataFile(fName As String)
Dim ff As Long
Dim int1 As Integer
Dim int2 As Integer
Dim i As Integer
Dim str As String
  ff = FreeFile
  Open CONSTPath & fName & ".map" For Input As ff
    Input #ff, str
    int1 = CInt(str)
    Input #ff, str
    int2 = CInt(str)
    Set Map = New Map
    Call Map.CreateArray(int1, int2)
    For i = 0 To Map.Cols * Map.Rows - 1
      'Debug.Print Input(1, #ff)
      'Input #ff, interg
      If Not EOF(ff) Then
        Input #ff, str
        int1 = CInt(str)

        Call Map.AddItem(int1, int2)
      Else
        Debug.Print i
      End If
    Next
  Close #1
End Sub
Private Sub Form_Resize()
  Outer.Width = Me.ScaleWidth - Outer.Left
  Outer.Height = Me.ScaleHeight - Outer.Top
  VScroll1.Left = Outer.ScaleWidth - VScroll1.Width
  VScroll1.Height = Outer.ScaleHeight
  HScroll1.Top = Outer.ScaleHeight - HScroll1.Height
  HScroll1.Left = 0
  HScroll1.Width = Outer.ScaleWidth - VScroll1.Width
End Sub
Private Sub Form_Unload(Cancel As Integer)
  Unload frmTextures
End Sub
Private Sub HScroll1_Change()
  'HScroll1.Value
  Inner.Left = 0 - (HScroll1.Value * 16 * ZoomLevel)
End Sub
Private Sub WriteToFile()
Dim ff As Long
Dim i As Integer
  ff = FreeFile
  Open CONSTPath & txtFile.Text & ".map" For Output As ff
    Write #ff, Map.Rows
    Write #ff, Map.Cols
    For i = 0 To Map.Rows * Map.Cols - 1
      Write #ff, Map(i).Image
'      Write #ff, Map(i).Image(1)
    Next
  Close #1
End Sub
Private Sub RedrawScreen()
Dim i As Integer
On Error GoTo 0
  imgTile(0).Width = (16 * ZoomLevel)
  imgTile(0).Height = (16 * ZoomLevel)
  imgTile(0).Stretch = True
  For i = 1 To Map.Rows * Map.Cols - 1
'    Load imgTile(i)
    imgTile(i).Visible = False
    imgTile(i).Left = imgTile(i - 1).Left + (16 * ZoomLevel)
    imgTile(i).Top = imgTile(i - 1).Top
    If CDbl((i / Map.Cols) - CInt(i / Map.Cols)) = 0 Then
      imgTile(i).Top = imgTile(i - 1).Top + (16 * ZoomLevel)
      imgTile(i).Left = imgTile(0).Left
    End If
    imgTile(i).Width = (16 * ZoomLevel)
    imgTile(i).Height = (16 * ZoomLevel)
    imgTile(i).Stretch = True
    'imgTile(i).Picture = imgAvailTiles(imgTile(i).Tag).Picture
    imgTile(i).Visible = True
  Next
  For i = 0 To 1
    castle(i).Width = (16 * ZoomLevel) / 2
    castle(i).Height = (16 * ZoomLevel) / 2
  Next
End Sub
Private Sub imgTile_DragDrop(Index As Integer, Source As Control, X As Single, y As Single)
  If (Me.ScaleX(X, vbTwips, vbPixels)) > (imgTile(Index).Width / 2) Then
    Source.Left = imgTile(Index).Width / 2
  Else
    Source.Left = 0
  End If
  Source.Left = Source.Left + imgTile(Index).Left
  If (ScaleY(y, vbTwips, vbPixels)) > (imgTile(Index).Height / 2) Then
    Source.Top = imgTile(Index).Height / 2
  Else
    Source.Top = 0
  End If
  Source.Top = Source.Top + imgTile(Index).Top
End Sub
Private Sub imgTile_DragOver(Index As Integer, Source As Control, X As Single, y As Single, State As Integer)
  If Source = imgSml Then
    imgTile(Index).Picture = imgZoom.Picture
   Map(Index).Image = imgZoom.Tag
  End If
End Sub
Private Sub imgTile_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, y As Single)
  ActiveTile = Index
  If imgZoom.Tag <> -1 Then
    If Button = vbLeftButton Then
     Map(Index).Image = imgZoom.Tag
     imgTile(Index).Picture = imgZoom.Picture
    Else
      Debug.Print X / Screen.TwipsPerPixelX & " : " & y / Screen.TwipsPerPixelY
    End If
  End If
End Sub
Private Sub Text1_LostFocus()
On Error Resume Next
  ZoomLevel = CDbl(Text1.Text)
  If ZoomLevel <= 0 Then ZoomLevel = 1
  Call RedrawScreen
End Sub
Private Sub vmdAbout_Click()
  frmAbout.Show 1, Me
End Sub
Private Sub VScroll1_Change()
  Inner.Top = 0 - (VScroll1.Value * 16 * ZoomLevel)
End Sub
Private Sub Draw()
Dim i As Integer
Dim j As Integer
Dim t As Double
  t = Timer
  If ImageLoaded Then
    For i = 0 To Map.Rows * Map.Cols - 1
      imgTile(i).Picture = frmTextures.picTile(Map(i).Image).Picture
    Next
    Debug.Print "Draw complete"
  End If
  t = Timer - t
  Debug.Print "Time to redraw :" & t
End Sub